home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / riscarithgen.t < prev    next >
Encoding:
Text File  |  1989-10-27  |  4.5 KB  |  121 lines
  1. (herald (back_end sparithgen)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define (machine-op inst)
  28.   (xcase inst
  29.     ((add) risc/add)
  30.     ((sub) risc/sub)
  31.     ((or) risc/or)
  32.     ((xor) risc/xor)
  33.     ((and) risc/and)))
  34.  
  35. (define (fixnum-comparator node inst)       
  36.   (comparator node inst))
  37.  
  38. (define (character-comparator node inst)
  39.   (comparator node inst))
  40.  
  41. (define (eq?-comparator node)
  42.   (comparator node jump-op/jn=))
  43.  
  44.  
  45. (define (comparator node jump-op)
  46.   (destructure (((then else () ref1 ref2) (call-args node)))
  47.     (let* ((val1 (leaf-value ref1))
  48.            (val2 (leaf-value ref2)))
  49.         (let ((acc2 (arith->addressable node val2 'cmp)))
  50.           (protect-access acc2)
  51.       (let ((acc1 (arith->addressable node val1 'cmp)))
  52.         (cond ((register? acc1)
  53.            (emit-compare jump-op
  54.                  acc1 acc2 else then))
  55.           ((register? acc2)
  56.            (emit-compare (reverse-jump-ops jump-op) acc2 acc1 else then))
  57.           (t
  58.            (generate-move acc1 extra)
  59.            (emit-compare jump-op extra acc2 else then))))
  60.           (release-access acc2)))))
  61.  
  62. (define (generate-numeric-op node inst)
  63.   (destructure (((cont right left) (call-args node)))
  64.       (let* ((lvar (leaf-value left))
  65.              (rvar (leaf-value right))
  66.              (l-acc (arith->addressable node lvar inst)))
  67.         (protect-access l-acc)
  68.         (let ((r-acc (arith->addressable node rvar inst)))
  69.           (release-access l-acc)
  70.       (let ((t-reg (get-target-register node cont l-acc r-acc)))
  71.         (receive (r-acc l-acc)
  72.           (cond ((register? r-acc) (return r-acc l-acc))
  73.             ((and (register? l-acc)
  74.               (memq? inst '(add and or xor)))
  75.              (return l-acc r-acc))
  76.             ((fx= rvar 0) (return zero l-acc))
  77.             (else
  78.              (generate-move r-acc extra)
  79.              (return extra l-acc)))
  80.           (case inst
  81.         ((ashl)
  82.          (cond ((fixnum? lvar)
  83.             (emit risc/sll (machine-num lvar) r-acc t-reg))
  84.                (else
  85.             (emit risc/sra (machine-num 2) l-acc scratch)
  86.             (emit risc/sll scratch r-acc t-reg))))
  87.         ((ashr)
  88.          (cond ((fixnum? lvar)
  89.             (emit risc/sra (machine-num (fx+ lvar 2)) r-acc scratch))
  90.                (else
  91.             (emit risc/sra (machine-num 2) l-acc scratch)
  92.             (emit risc/add (machine-num 2) scratch scratch)
  93.             (emit risc/sra scratch r-acc scratch)))
  94.          (emit risc/sll (machine-num 2) scratch t-reg))
  95.         ((mul)
  96.          (generate-multiply lvar l-acc r-acc t-reg))
  97.         ((div)
  98.          (generate-divide lvar l-acc r-acc t-reg))
  99.         ((rem)
  100.          (generate-remainder lvar l-acc r-acc t-reg))
  101.         (else
  102.          (emit (machine-op inst) l-acc r-acc t-reg)))
  103.           (mark-continuation node t-reg)))))))
  104.  
  105. (define (generate-char->ascii node)
  106.   (destructure (((cont arg) (call-args node)))
  107.       (let* ((var (leaf-value arg))
  108.              (acc (->register node var))
  109.          (t-reg (get-target-register node cont acc nil)))
  110.     (emit risc/srl (machine-num 6) acc t-reg)
  111.     (mark-continuation node t-reg))))
  112.  
  113. (define (generate-ascii->char node)
  114.   (destructure (((cont arg) (call-args node)))
  115.       (let* ((var (leaf-value arg))
  116.              (acc (->register node var))
  117.          (t-reg (get-target-register node cont acc nil)))
  118.     (emit risc/sll (machine-num 6) acc t-reg)
  119.     (emit risc/or (machine-num header/char) t-reg t-reg)
  120.     (mark-continuation node t-reg))))
  121.